home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / gls / genwrite.scm < prev    next >
Encoding:
Text File  |  1995-08-10  |  9.3 KB  |  265 lines
  1. ;"genwrite.scm" generic write used by pp.scm
  2. ;;Copyright (c) 1991, Marc Feeley
  3.  
  4. (define (symbol->print-name symbol)
  5.   (call-with-output-string
  6.    (lambda (p) (write symbol p))))
  7.  
  8. (define (generic-write obj display? width output)
  9.  
  10.   (define (read-macro? l)
  11.     (define (length1? l) (and (pair? l) (null? (cdr l))))
  12.     (let ((head (car l)) (tail (cdr l)))
  13.       (case head
  14.         ((QUOTE QUASIQUOTE UNQUOTE UNQUOTE-SPLICING) (length1? tail))
  15.         (else                                        #f))))
  16.  
  17.   (define (read-macro-body l)
  18.     (cadr l))
  19.  
  20.   (define (read-macro-prefix l)
  21.     (let ((head (car l)) (tail (cdr l)))
  22.       (case head
  23.         ((QUOTE)            "'")
  24.         ((QUASIQUOTE)       "`")
  25.         ((UNQUOTE)          ",")
  26.         ((UNQUOTE-SPLICING) ",@"))))
  27.  
  28.   (define (out str col)
  29.     (and col (output str) (+ col (string-length str))))
  30.  
  31.   (define (wr obj col)
  32.  
  33.     (define (wr-expr expr col)
  34.       (if (read-macro? expr)
  35.         (wr (read-macro-body expr) (out (read-macro-prefix expr) col))
  36.         (wr-lst expr col)))
  37.  
  38.     (define (wr-lst l col)
  39.       (if (pair? l)
  40.         (let loop ((l (cdr l)) (col (wr (car l) (out "(" col))))
  41.           (and col
  42.                (cond ((pair? l) (loop (cdr l) (wr (car l) (out " " col))))
  43.                      ((null? l) (out ")" col))
  44.                      (else      (out ")" (wr l (out " . " col)))))))
  45.         (out "()" col)))
  46.  
  47.     (cond ((pair? obj)        (wr-expr obj col))
  48.           ((null? obj)        (wr-lst obj col))
  49.           ((vector? obj)      (wr-lst (vector->list obj) (out "#" col)))
  50.           ((boolean? obj)     (out (if obj "#t" "#f") col))
  51.           ((number? obj)      (out (number->string obj) col))
  52.           ((symbol? obj)      (out (symbol->print-name obj) col))
  53.           ((procedure? obj)   (out "#[procedure]" col))
  54.           ((string? obj)      (if display?
  55.                                 (out obj col)
  56.                                 (let loop ((i 0) (j 0) (col (out "\"" col)))
  57.                                   (if (and col (< j (string-length obj)))
  58.                                     (let ((c (string-ref obj j)))
  59.                                       (if (or (char=? c #\\)
  60.                                               (char=? c #\"))
  61.                                         (loop j
  62.                                               (+ j 1)
  63.                                               (out "\\"
  64.                                                    (out (substring obj i j)
  65.                                                         col)))
  66.                                         (loop i (+ j 1) col)))
  67.                                     (out "\""
  68.                                          (out (substring obj i j) col))))))
  69.           ((char? obj)        (if display?
  70.                                 (out (make-string 1 obj) col)
  71.                                 (out (case obj
  72.                                        ((#\space)   "space")
  73.                                        ((#\newline) "newline")
  74.                                        (else        (make-string 1 obj)))
  75.                                      (out "#\\" col))))
  76.           ((input-port? obj)  (out "#[input-port]" col))
  77.           ((output-port? obj) (out "#[output-port]" col))
  78.           ((eof-object? obj)  (out "#[eof-object]" col))
  79.           (else               (out "#[unknown]" col))))
  80.  
  81.   (define (pp obj col)
  82.  
  83.     (define (spaces n col)
  84.       (if (> n 0)
  85.         (if (> n 7)
  86.           (spaces (- n 8) (out "        " col))
  87.           (out (substring "        " 0 n) col))
  88.         col))
  89.  
  90.     (define (indent to col)
  91.       (and col
  92.            (if (< to col)
  93.              (and (out (make-string 1 #\newline) col) (spaces to 0))
  94.              (spaces (- to col) col))))
  95.  
  96.     (define (pr obj col extra pp-pair)
  97.       (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
  98.         (let ((result '())
  99.               (left (min (+ (- (- width col) extra) 1) max-expr-width)))
  100.           (generic-write obj display? #f
  101.             (lambda (str)
  102.               (set! result (cons str result))
  103.               (set! left (- left (string-length str)))
  104.               (> left 0)))
  105.           (if (> left 0) ; all can be printed on one line
  106.             (out (reverse-string-append result) col)
  107.             (if (pair? obj)
  108.               (pp-pair obj col extra)
  109.               (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
  110.         (wr obj col)))
  111.  
  112.     (define (pp-expr expr col extra)
  113.       (if (read-macro? expr)
  114.         (pr (read-macro-body expr)
  115.             (out (read-macro-prefix expr) col)
  116.             extra
  117.             pp-expr)
  118.         (let ((head (car expr)))
  119.           (if (symbol? head)
  120.             (let ((proc (style head)))
  121.               (if proc
  122.                 (proc expr col extra)
  123.                 (if (> (string-length (symbol->print-name head))
  124.                        max-call-head-width)
  125.                   (pp-general expr col extra #f #f #f pp-expr)
  126.                   (pp-call expr col extra pp-expr))))
  127.             (pp-list expr col extra pp-expr)))))
  128.  
  129.     ; (head item1
  130.     ;       item2
  131.     ;       item3)
  132.     (define (pp-call expr col extra pp-item)
  133.       (let ((col* (wr (car expr) (out "(" col))))
  134.         (and col
  135.              (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))
  136.  
  137.     ; (item1
  138.     ;  item2
  139.     ;  item3)
  140.     (define (pp-list l col extra pp-item)
  141.       (let ((col (out "(" col)))
  142.         (pp-down l col col extra pp-item)))
  143.  
  144.     (define (pp-down l col1 col2 extra pp-item)
  145.       (let loop ((l l) (col col1))
  146.         (and col
  147.              (cond ((pair? l)
  148.                     (let ((rest (cdr l)))
  149.                       (let ((extra (if (null? rest) (+ extra 1) 0)))
  150.                         (loop rest
  151.                               (pr (car l) (indent col2 col) extra pp-item)))))
  152.                    ((null? l)
  153.                     (out ")" col))
  154.                    (else
  155.                     (out ")"
  156.                          (pr l
  157.                              (indent col2 (out "." (indent col2 col)))
  158.                              (+ extra 1)
  159.                              pp-item)))))))
  160.  
  161.     (define (pp-general expr col extra named? pp-1 pp-2 pp-3)
  162.  
  163.       (define (tail1 rest col1 col2 col3)
  164.         (if (and pp-1 (pair? rest))
  165.           (let* ((val1 (car rest))
  166.                  (rest (cdr rest))
  167.                  (extra (if (null? rest) (+ extra 1) 0)))
  168.             (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
  169.           (tail2 rest col1 col2 col3)))
  170.  
  171.       (define (tail2 rest col1 col2 col3)
  172.         (if (and pp-2 (pair? rest))
  173.           (let* ((val1 (car rest))
  174.                  (rest (cdr rest))
  175.                  (extra (if (null? rest) (+ extra 1) 0)))
  176.             (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
  177.           (tail3 rest col1 col2)))
  178.  
  179.       (define (tail3 rest col1 col2)
  180.         (pp-down rest col2 col1 extra pp-3))
  181.  
  182.       (let* ((head (car expr))
  183.              (rest (cdr expr))
  184.              (col* (wr head (out "(" col))))
  185.         (if (and named? (pair? rest))
  186.           (let* ((name (car rest))
  187.                  (rest (cdr rest))
  188.                  (col** (wr name (out " " col*))))
  189.             (tail1 rest (+ col indent-general) col** (+ col** 1)))
  190.           (tail1 rest (+ col indent-general) col* (+ col* 1)))))
  191.  
  192.     (define (pp-expr-list l col extra)
  193.       (pp-list l col extra pp-expr))
  194.  
  195.     (define (pp-LAMBDA expr col extra)
  196.       (pp-general expr col extra #f pp-expr-list #f pp-expr))
  197.  
  198.     (define (pp-IF expr col extra)
  199.       (pp-general expr col extra #f pp-expr #f pp-expr))
  200.  
  201.     (define (pp-COND expr col extra)
  202.       (pp-call expr col extra pp-expr-list))
  203.  
  204.     (define (pp-CASE expr col extra)
  205.       (pp-general expr col extra #f pp-expr #f pp-expr-list))
  206.  
  207.     (define (pp-AND expr col extra)
  208.       (pp-call expr col extra pp-expr))
  209.  
  210.     (define (pp-LET expr col extra)
  211.       (let* ((rest (cdr expr))
  212.              (named? (and (pair? rest) (symbol? (car rest)))))
  213.         (pp-general expr col extra named? pp-expr-list #f pp-expr)))
  214.  
  215.     (define (pp-BEGIN expr col extra)
  216.       (pp-general expr col extra #f #f #f pp-expr))
  217.  
  218.     (define (pp-DO expr col extra)
  219.       (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
  220.  
  221.     ; define formatting style (change these to suit your style)
  222.  
  223.     (define indent-general 2)
  224.  
  225.     (define max-call-head-width 5)
  226.  
  227.     (define max-expr-width 50)
  228.  
  229.     (define (style head)
  230.       (case head
  231.         ((LAMBDA LET* LETREC DEFINE) pp-LAMBDA)
  232.         ((IF SET!)                   pp-IF)
  233.         ((COND)                      pp-COND)
  234.         ((CASE)                      pp-CASE)
  235.         ((AND OR)                    pp-AND)
  236.         ((LET)                       pp-LET)
  237.         ((BEGIN)                     pp-BEGIN)
  238.         ((DO)                        pp-DO)
  239.         (else                        #f)))
  240.  
  241.     (pr obj col 0 pp-expr))
  242.  
  243.   (if width
  244.     (out (make-string 1 #\newline) (pp obj 0))
  245.     (wr obj 0)))
  246.  
  247. ; (reverse-string-append l) = (apply string-append (reverse l))
  248.  
  249. (define (reverse-string-append l)
  250.  
  251.   (define (rev-string-append l i)
  252.     (if (pair? l)
  253.       (let* ((str (car l))
  254.              (len (string-length str))
  255.              (result (rev-string-append (cdr l) (+ i len))))
  256.         (let loop ((j 0) (k (- (- (string-length result) i) len)))
  257.           (if (< j len)
  258.             (begin
  259.               (string-set! result k (string-ref str j))
  260.               (loop (+ j 1) (+ k 1)))
  261.             result)))
  262.       (make-string i)))
  263.  
  264.   (rev-string-append l 0))
  265.